home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / Modes / shellMode.tcl < prev    next >
Text File  |  1996-08-15  |  13KB  |  531 lines
  1.  
  2. ################################################################################
  3. # Shell routines.
  4. ################################################################################
  5.  
  6. if $startingUp {
  7.     addMode Shel dummyShel {"*tcl¥ sh*"} { tclMenu }
  8.     newModeVar Shel wordBreak {(¥$)?[a-zA-Z0-9_.]+} 0
  9.     newModeVar Shel wordWrap {0} 1
  10.     newModeVar Shel wordBreakPreface {[^a-zA-Z0-9_¥$]} 0
  11.     newModeVar Shel autoMark    0    1
  12.     regModeKeywords -m {ﾇ} Shel {}
  13.     return
  14. }
  15.  
  16.  
  17. set otherDirs {}
  18.  
  19. proc pushd {args} {
  20.     global otherDirs
  21.     if {[string length $args]} {
  22.         set otherDirs [cons [pwd] $otherDirs]
  23.         cd [string trim [eval list $args] "        ¥{¥}"]
  24.     } else {
  25.         if {[llength $otherDirs]} {
  26.             set n [car $otherDirs]
  27.             set otherDirs [cons [pwd] [cdr $otherDirs]]
  28.             cd $n
  29.         } else {
  30.             return "No other directories"
  31.         }
  32.     }
  33. }
  34. proc pd {args} {
  35.     if {[string length $args]} {
  36.         eval pushd $args
  37.     } else {
  38.         pushd
  39.     }
  40. }
  41.  
  42.  
  43. proc dirs {} {global otherDirs; cons [pwd] $otherDirs}
  44.  
  45. proc popd {} {
  46.     global otherDirs
  47.     if {[llength $otherDirs]} {
  48.         cd [car $otherDirs]
  49.         set otherDirs [cdr $otherDirs]
  50.     } else {
  51.         return "No other directories"
  52.     }
  53. }
  54.  
  55.  
  56. proc setShellMode {} {
  57.     setTclMode
  58.     changeMode "Shel"
  59.     insertMenu "Tcl"
  60. }
  61.  
  62. proc initShell {} {
  63.     insertText "Welcome to Alpha's Tcl shell."
  64.     insertText -w [lindex [winNames] 0] [shellPrompt]
  65. }
  66.  
  67. # Return the prompt. We want the window name because some of the commands
  68. # we evaluate (such as 'edit') open a new window, and we want the insertion
  69. # to be done in the shell window.
  70. proc shellPrompt {} {
  71.     return "¥rﾇ[file tail [string trimright [pwd] {:}]]ﾈ "
  72. }
  73.  
  74.  
  75. proc shellCarriageReturn {} {
  76.     global mode histnum
  77.     global _text
  78.     global _returnText
  79.     set pos [getPos]
  80.  
  81.     if {![catch {regexp {ｰ} [getText $pos [nextLineStart $pos]]} res] && $res} {
  82.         gotoMatch; return;
  83.     }
  84.     set ind [string first "ﾈ" [getText [lineStart $pos] $pos]]
  85.     if {$ind < 0} {
  86.         carriageReturn
  87.         return
  88.     }
  89.     set lStart [expr [lineStart $pos]+$ind+2]
  90.     endOfLine
  91.     set _text [getText $lStart [getPos]]
  92.     set fileName [lindex [winNames] 0]
  93.     if {[getPos] != [maxPos]} {
  94.         goto [maxPos]
  95.         insertText -w $fileName $_text
  96.     }
  97.     if {[string first "Toolserver" $fileName] != -1} {
  98.         if {![catch {dosc -n ToolServer -s $_text} _returnText]} {
  99.             insertText "¥r" $_returnText
  100.         } else {
  101.             insertText "¥r"
  102.         }
  103.         mpwPrompt
  104.     } elseif {$fileName == "* Comet Server *"} {
  105.         cometSendAndPrompt $_text
  106.     } else {
  107.         uplevel #0 {catch $_text _returnText}
  108.         history add $_text
  109.         if {[string length $_returnText]} {
  110.             insertText -w $fileName "¥r" $_returnText [shellPrompt]
  111.         } else {
  112.             insertText -w $fileName [shellPrompt]
  113.         }
  114.         set histnum [history nextid]
  115.     }
  116.     unset _text
  117.     unset _returnText
  118. }
  119. bind '¥r' carriageReturn
  120. bind '¥r' shellCarriageReturn "Shel"
  121. bind '¥r' shellCarriageReturn "MPW"
  122.  
  123.  
  124. bind up <z> prevHist Shel
  125. bind down <z> nextHist Shel
  126.  
  127. proc prevHist {} {
  128.     global histnum
  129.     
  130.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  131.     if {[set ind [string first "ﾈ " $text]] > 0} {
  132.         goto [expr [lineStart [getPos]] + $ind + 2]
  133.     } else return
  134.  
  135.     incr histnum -1
  136.     if {[catch {history event $histnum} text]} {
  137.         incr histnum
  138.         endOfLine
  139.         return
  140.     }
  141.     set to [nextLineStart [getPos]]
  142.     if {[lookAt [expr $to-1]] == "¥r"} {incr to -1}
  143.     replaceText [getPos] $to $text
  144. }
  145.  
  146.  
  147. proc nextHist {} {
  148.     global histnum
  149.     
  150.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  151.     if {[set ind [string first "ﾈ " $text]] > 0} {
  152.         goto [expr [lineStart [getPos]] + $ind + 2]
  153.     } else return
  154.  
  155.     incr histnum
  156.     if {[catch {history event $histnum} text]} {
  157.         incr histnum -1
  158.         endOfLine
  159.         return
  160.     }
  161.     set to [nextLineStart [getPos]]
  162.     if {[lookAt [expr $to-1]] == "¥r"} {incr to -1}
  163.     replaceText [getPos] $to $text
  164. }
  165.  
  166.     
  167. proc startMPW {} {
  168.     global toolserverPath
  169.  
  170.     if {![string length [checkRunning ToolServer MPSX toolserverPath]]} return
  171.  
  172.     insertText "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents)."
  173.     bind '¥r' shellCarriageReturn "MPW"
  174.     carriageReturn
  175.     mpwPrompt
  176. }
  177. proc mpwPrompt {} {
  178.     insertText "ﾇmpwﾈ "
  179. }
  180.  
  181. proc setMPWMode {} {
  182.     changeMode "MPW"
  183. }
  184.  
  185. #    shellCarriageReturn
  186.  
  187.  
  188.  
  189. #=============================================================================
  190. #    Shell Aliases
  191. #=============================================================================
  192.  
  193.  
  194. proc l {args} {
  195.     eval [concat "ls -CF" $args]}
  196.  
  197. proc ll {args} {
  198.     eval [concat "ls -l" $args]}
  199.  
  200.  
  201. proc wc {args} {
  202.     set res {}
  203.     set totChars 0
  204.     set totLines 0
  205.     set totWords 0
  206.     set args [glob -nocomplain $args]
  207.     foreach file $args {
  208.         set id [open $file]
  209.         set chars [string length [set text [read $id]]]
  210.         set lines [llength [split $text "¥n"]]
  211.         set words [llength [split $text]]
  212.         append res [format "¥r%8d%8d%8d    $file" $lines $words $chars]
  213.         set totChars [expr $totChars+$chars]
  214.         set totWords [expr $totWords+$words]
  215.         set totLines [expr $totLines+$lines]
  216.         close $id
  217.     }
  218.     if {[llength $args] > 1} {
  219.         append res [format "¥r%8d%8d%8d    total" $totLines $totWords $totChars]
  220.     }
  221.     return [string range $res 1 end]
  222. }
  223.  
  224. #================================================================================
  225.  
  226.  
  227. proc tclFileCompletion {} {
  228.     set silly "*"
  229.     set pos [getPos]
  230.     set res [search -f 0 -i 0 -m 0 -r 1 -n {["¥{ ¥t¥r]} [expr $pos - 1]]
  231.     if {[string length $res]} {
  232.         set from [lindex $res 1]
  233.         if {$from < $pos} {
  234.             set pd [pwd]
  235.             set text [getText $from $pos]
  236.             if {[string index $text 0] == ":"} {
  237.                 set pd [string trimright $pd ":"]
  238.             }
  239.             if {[catch {glob $pd$text$silly} globbed]} {
  240.                 set globbed [glob $text$silly]
  241.                 set pd ""
  242.             }
  243.             if {[llength $globbed] == 1} {
  244.                 set len [string length $pd$text]
  245.                 insertText [string range [lindex $globbed 0] $len end]
  246.             } elseif {[llength $globbed] != 0} {
  247.                 set globbed [lsort $globbed]
  248.                 set one [lindex $globbed 0]
  249.                 set two [lindex $globbed end]
  250.                 
  251.                 set len [string length $pd$text]
  252.                 set one [string range $one $len end]
  253.                 set two [string range $two $len end]
  254.                 
  255.                 set elen [string length $one]
  256.                 if {[string length $two] < $elen} {
  257.                     set elen [string length $two]
  258.                 }
  259.                 set len 0
  260.                 set str ""
  261.                 while {($len < $elen) && ([string match $str[string index $one $len]$silly $two])} {
  262.                     append str [string index $one $len]
  263.                     incr len
  264.                 }
  265.  
  266.                 if {!$len} {
  267.                     set elen [string length $pd]
  268.                     foreach g $globbed {
  269.                         lappend short [string range $g $elen end]
  270.                     }
  271.                     set blah [getText [lineStart [getPos]] [getPos]]
  272.                     insertText "¥r" $short "¥r" $blah
  273.                 } else {
  274.                     insertText $str
  275.                 }
  276.             }
  277.         }
  278.     }
  279. }
  280.  
  281.  
  282.  
  283. #================================================================================
  284. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  285. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  286. # assumed to be the parent directory of the top directory we are creating.
  287. #================================================================================
  288. proc cpdir {from to} {
  289.     set cwd [pwd]
  290.     if {[string match ":*" $from] || [string match ":*" $to] ||
  291.         ![file exists $from] || ![file exists $to]} {
  292.         error "'cpdir' args must be complete pathnames of existing folders."
  293.     }
  294.     if {![string match "*:" $from]} {append from ":"}
  295.     if {![string match "*:" $to]} {append to ":"}
  296.     
  297.     if {![file isdir $from] || ![file isdir $to]} {
  298.         exit 1
  299.     }
  300.         
  301.     set res [catch {cphier $from $to} val]
  302.     cd $cwd
  303.     if {$res} {error $val}
  304. }
  305.  
  306. proc cphier {from to} {
  307.     set savedir [pwd]
  308.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  309.     set dir [file tail [string trimright $from ":"]]
  310.     cd $to
  311.     mkdir "$dir"
  312.     foreach f [glob "$from*"] {
  313.         if {[file isdir $f]} {
  314.             cphier "$f:" "$to$dir:"
  315.         } else {
  316.             cp $f $to$dir:
  317.         }
  318.     }
  319.     cd $savedir
  320. }
  321.  
  322.  
  323. proc shellBol {} {
  324.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  325.     if {[set ind [string first "ﾈ " $text]] > 0} {
  326.         goto [expr [lineStart [getPos]] + $ind + 2]
  327.     } else {
  328.         goto [lineStart [getPos]]
  329.     }
  330. }
  331. bind 'a' <z> shellBol Shel
  332.  
  333.  
  334. proc dummyShel {} {dummyTcl}
  335.  
  336. #================================================================================
  337.  
  338. proc shellup {} {
  339.     set pos [expr [lineStart [getPos]] - 1]
  340.     if {[catch {regexp {ｰ} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  341.         previousLine; return
  342.     }
  343.     select [lineStart $pos] [nextLineStart $pos]
  344. }
  345. bind up shellup Shel
  346.  
  347.  
  348. proc shelldown {} {
  349.     set pos [nextLineStart [getPos]]
  350.     if {[catch {regexp {ｰ} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  351.         nextLine; return
  352.     }
  353.     select $pos [nextLineStart $pos]
  354. }
  355. bind down shelldown Shel
  356.  
  357.         
  358. #================================================================================
  359. #####
  360. # (Usage:  'lt' sorts by time, like UNIX's 'ls -lt'.
  361. #          'lt -t' sorts by filename, like UNIX's 'ls -l'.
  362. #          Optionally a directory name can be added as an argument.)
  363.  
  364. proc sortdt {dt} {
  365.         scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  366.         if {$z == "P"} {incr hou 12}
  367.         if {[string length $yea] == 1} {
  368.                 set year 200$yea
  369.         } elseif {$yea > 40} {
  370.                 set year 19$yea
  371.         } else {
  372.                 set year 20$yea
  373.         }
  374.         return [format "%04d%02d%02d%02d%02d" $year $mon $day $hou $min]
  375. }
  376.  
  377.  
  378. proc lth args {
  379.         global mode
  380.         
  381.         set val "*"
  382.         set sort 1
  383.         scan [lindex [mtime [now]] 0] "%d/%d/%d" one two three
  384.         if {[string length $three] == 1} {
  385.                 set year 200$three
  386.         } elseif {$three > 40} {
  387.                 set year 19$three
  388.         } else {
  389.                 set year 20$three
  390.         }
  391.         
  392.         foreach arg $args {
  393.                 switch -- $arg {
  394.                         "-t"    {set sort 0}
  395.                         default {set val $arg}
  396.                 }
  397.         }
  398.         set mod ""
  399.         foreach f [eval glob $val] {
  400.                 if {[catch {getFileInfo $f info}]} {
  401.                         if {$sort} {set mod "000000000000 "}
  402.                         lappend text [format "%s%s %8d%8d %6s %5s %4s %s %s¥n" $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  403.                         continue
  404.                 }
  405.                 if {$sort} {set mod "[sortdt [mtime $info(modified) s]] "}
  406.                 set m [mtime $info(modified) a]
  407.                 set zer [lindex $m 0]
  408.                 set dat [format "%s %2s" [lindex $zer 1] [string trimright [lindex $zer 2] {,}]]
  409.                 if {[lindex $zer 3] == $year} {
  410.                         if {[scan [lindex $m 1] "%d:%d:%d %s" one two three am] != 4} {
  411.                                 error "Didn't get four from scan"
  412.                         }
  413.                         if {[string length $two] == 1} {set two "0$two"}
  414.                         set tm [expr {$am == "AM"} ? $one : [expr $one + 12]]:$two
  415.                 } else {
  416.                         set tm " [lindex $zer 3]"
  417.                 }
  418.                 lappend text [format "%sF %8d%8d %s %5s %s %s %s¥n" $mod $info(datalen) $info(resourcelen) $dat $tm $info(type) $info(creator) [file tail $f]]
  419.         }
  420.         if {$sort} {
  421.                 foreach ln [lsort -de $text] {
  422.                         append txt [string range $ln 13 end]
  423.                 }
  424.                 set ans [string trimright $txt]
  425.         } else {
  426.                 set ans [string trimright [join $text {}]]
  427.         }
  428.         
  429.         if { $mode=="Shel" } { return $ans } else {
  430.                 new
  431.                 insertText $ans "¥r"
  432.                 catch shrinkHeight
  433.                 setWinInfo dirty 0
  434.                 setWinInfo read-only 1
  435.         }
  436. }
  437.  
  438. #================================================================================
  439. proc ps {} {
  440.     foreach p [processes] {
  441.         append text [format "%-25s %4s %10d %10d¥r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  442.     }
  443.     return [string trimright $text]
  444. }
  445.  
  446.  
  447. #================================================================================
  448. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  449. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  450. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  451. proc creator {{dir ":"}}  {
  452.     if {![catch {glob -t TEXT $dir*} files]} {
  453.         foreach f $files {
  454.             message $f
  455.             setFileInfo $f creator ALFA
  456.         }
  457.     }
  458.  
  459.     if {![catch {glob $dir*} dirs]} {
  460.         foreach d $dirs {
  461.             if {[file isdir $d]} {creator $d:}
  462.         }
  463.     }
  464. }
  465.  
  466.  
  467.  
  468. #===============================================================================
  469.  
  470. proc ShelDblClick {args} { eval TclDblClick $args }
  471.  
  472. #===============================================================================
  473.  
  474. proc tomac args {
  475.     set files {}
  476.     foreach arg $args {
  477.         append files " " [glob $arg]
  478.     }
  479.     set dir [pwd]
  480.     
  481.     foreach f $files {
  482.         message "$f..."
  483.         set fd [open $dir$f "r"]
  484.         set text [read $fd]
  485.         close $fd
  486.         regsub "¥n" $text "¥r" text
  487.         
  488.         set fd [open "$dir$f" "w"]
  489.         puts -nonewline $fd $text
  490.         close $fd
  491.     }
  492.     message ""
  493. }
  494.  
  495.  
  496. #===============================================================================
  497.  
  498. proc unixToMac {fname} {
  499.     set fd [open $fname]
  500.     set text [read $fd]
  501.     close $fd
  502.     set fd [open $fname "w"]
  503.     puts -nonewline $fd $text
  504.     close $fd
  505. }
  506.  
  507. proc setCreator args {
  508.     set files {}
  509.     set creator [car $args]
  510.     foreach arg [cdr $args] {
  511.         append files " " [glob $arg]
  512.     }
  513.     
  514.     foreach f $files {
  515.         setFileInfo $f creator $creator
  516.     }
  517. }
  518.  
  519. proc setType args {
  520.     set files {}
  521.     set type [car $args]
  522.     foreach arg [cdr $args] {
  523.         append files " " [glob $arg]
  524.     }
  525.     
  526.     foreach f $files {
  527.         setFileInfo $f type $type
  528.     }
  529. }
  530. #===============================================================================
  531.